Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/common2r/sendbug.frm

Text File | 1999-08-27 | 9KB | 329 lines

VERSION 5.00
Begin VB.Form Form7
   Appearance      =   0  '2D
   BackColor       =   &H00808080&
   BorderStyle     =   0  'Kein
   Caption         =   "Send Bug Report"
   ClientHeight    =   3192
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3192
   ScaleWidth      =   4680
   StartUpPosition =   2  'Bildschirmmitte
   Begin VB.TextBox DataArrival
      Appearance      =   0  '2D
      Height          =   288
      Left            =   960
      TabIndex        =   3
      Text            =   "Text1"
      Top             =   2760
      Visible         =   0   'False
      Width           =   1212
   End
   Begin VB.CommandButton Exit
      Appearance      =   0  '2D
      Caption         =   "Exit"
      Height          =   255
      Left            =   2280
      TabIndex        =   2
      Top             =   2880
      Width           =   2295
   End
   Begin VB.CommandButton SendBugConnect
      Appearance      =   0  '2D
      Caption         =   "Send Feedback"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   2880
      Width           =   2055
   End
   Begin VB.TextBox Bugreporttxt
      Appearance      =   0  '2D
      Height          =   2655
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   0
      Top             =   120
      Width           =   4455
   End
End
Attribute VB_Name = "Form7"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************
'*New Updates:
'
'-Api Declarations! (needs no Winsock.ocx)
'
'-Check if the Server respond with the right code
'
'-Perform a better error check
'
'-Use a better timeout routine to check if the Server
'times out
'
'
'*******************************************

Option Explicit
Private bTrans As Boolean
Private m_iStage As Integer
Private Sock As Integer
Private RC As Integer
Private Bytes As Integer
Private ResponseCode As Integer

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'CHANGE THIS SETTING LIKE YOU NEED IT
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Private Const mailserver As String = "127.0.0.1"
Private Const Tobox As String = "[e-mail]"
Private Const Frombox As String = "[e-mail]"
Private Const Subject As String = "User Feedback!"

'This is for the WaitforResponse Routine
Private Declare Function timeGetTime Lib "winmm.dll" () As Long


'***************************************************************
'Routine for connecting to the server
'***************************************************************

Sub SendBugConnect_Click()
Dim StartupData As WSADataType
Dim SocketBuffer As sockaddr
Dim IpAddr As Long

'Ini the Winsocket
RC = WSAStartup(&H101, StartupData)
RC = WSAStartup(&H101, StartupData)



'Open a free Socket (with this source code you can also
'open several connections! Very useful for E-Mail Applications...)
Sock = socket(AF_INET, SOCK_STREAM, 0)
If Sock = SOCKET_ERROR Then
    MsgBox "Cannot Create Socket."
    Exit Sub
End If

'Checks if the Hostname exists
If RC = SOCKET_ERROR Then Exit Sub
IpAddr = GetHostByNameAlias(mailserver)
If IpAddr = -1 Then
    MsgBox "Unknown Host: " + mailserver
    Exit Sub
End If


'This part is responsible for the connection
SocketBuffer.sin_family = AF_INET
SocketBuffer.sin_port = htons(25)
SocketBuffer.sin_addr = IpAddr
SocketBuffer.sin_zero = String$(8, 0)

RC = connect(Sock, SocketBuffer, Len(SocketBuffer))

'If an error occured close the connection and
'send an error message to the text window
If RC = SOCKET_ERROR Then
        MsgBox "Cannot Connect to " + mailserver + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
End If

'Select Receive Window
RC = WSAAsyncSelect(Sock, DataArrival.hWnd, _
                        ByVal &H202, ByVal FD_READ Or FD_CLOSE)
    If RC = SOCKET_ERROR Then
        MsgBox "Cannot Process Asynchronously."
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If

bTrans = True
m_iStage = 0
DataArrival = ""

ResponseCode = 220
Call WaitForResponse

End Sub

'***************************************************************
'Transmit the E-Mail
'***************************************************************

Private Sub Transmit(iStage As Integer)
Dim Helo As String, temp As String
Dim pos As Integer

Select Case m_iStage

Case 1:
    Helo = Frombox
    pos = Len(Helo) - InStr(Helo, "@")
    Helo = Right$(Helo, pos)

    ResponseCode = 250
    WinsockSendData ("HELO " & Helo & vbCrLf)
    Call WaitForResponse

Case 2:
    ResponseCode = 250
    WinsockSendData ("MAIL FROM: <" & Trim(Frombox) & ">" & vbCrLf)
    Call WaitForResponse

Case 3:
    ResponseCode = 250
    WinsockSendData ("RCPT TO: <" & Trim(Tobox) & ">" & vbCrLf)
    Call WaitForResponse

Case 4:
    ResponseCode = 354
    WinsockSendData ("DATA" & vbCrLf)
    Call WaitForResponse

Case 5:

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'If you want additional Headers like Date,Message-Id,...etc. !
'simply add them below                                      !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    temp = temp & "From: " & Frombox & vbNewLine
    temp = temp & "To: " & Tobox & vbNewLine
    temp = temp & "Subject: " & Subject & vbNewLine

    'Header + Message
    temp = temp & vbCrLf & Bugreporttxt.Text

    'Send the Message & close connection
    WinsockSendData (temp)
    WinsockSendData (vbCrLf & "." & vbCrLf)
    ResponseCode = 250
    Call WaitForResponse

Case 6:
    WinsockSendData ("QUIT" & vbCrLf)
    ResponseCode = 221
    Call WaitForResponse
    m_iStage = 0
    bTrans = False
End Select
End Sub


'***************************************************************
'Routine for arraving Data
'***************************************************************

Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MsgBuffer As String * 2048



On Error Resume Next



    If Sock > 0 Then
        'Receive up to 2048 chars
        Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)

        If Bytes > 0 Then


        If bTrans Then
            If ResponseCode = Left(MsgBuffer, 3) Then
            MsgBuffer = vbNullString
            m_iStage = m_iStage + 1
            Transmit m_iStage
            Else
                closesocket (Sock)
                RC = WSACleanup()
                Sock = 0
                MsgBox "The Server responds with an unexpected Response Code!", vbOKOnly, "Error!"
                Exit Sub
            End If
        End If

        ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
            closesocket (Sock)
            RC = WSACleanup()
            Sock = 0
        End If
    End If

Refresh


End Sub

'**************************************************************
' Waits until time out, while waiting for response
'**************************************************************

Private Sub WaitForResponse()
Dim Start As Integer
Dim Tmr As Integer

'Works with an Api Declaration because it's more precious

Start = timeGetTime
While Bytes > 0
    Tmr = timeGetTime - Start
    DoEvents ' Let System keep checking for incoming response

    'Wait 50 seconds for response
    If Tmr > 50000 Then
        MsgBox "SMTP service error, timed out while waiting for response", 64, "Error!"
        End
    End If
Wend
End Sub

Private Sub WinsockSendData(DatatoSend As String)
Dim RC As Integer